home *** CD-ROM | disk | FTP | other *** search
/ Especial Multimedia / Especial Multimedia.iso / Multimed / Presenta / EV2FREE.ZIP / EFREE3.ICZ / EDLLDRV.BAS < prev    next >
BASIC Source File  |  1995-03-06  |  10KB  |  321 lines
  1. 'Declare Function Play% Lib "mhen200.vbx" (ByVal Lin$)
  2. 'Declare Sub PlayStop Lib "mhen200.vbx" ()
  3. 'Declare Function MhASCIIMid% Lib "Muscle.vbx" (a$, ByVal Position%)
  4. 'Declare Function MhHexStrInt$ Lib "Muscle.vbx" (ByVal Fmt%, IntVal%)
  5. 'Declare Function MhHexValInt% Lib "Muscle.vbx" (Hexa$)
  6. 'Declare Function MhReplaceChar$ Lib "Muscle.vbx" (Lin$, ByVal OldChar%, ByVal NewChar%)
  7. 'Declare Function MhSpecToken$ Lib "Muscle.vbx" (ByVal Which%, Spec$)
  8. 'Declare Function MhWinDir$ Lib "Muscle.vbx" ()
  9. 'Declare Function cvc@ Lib "Muscle.vbx" (ByVal Lin$)
  10. 'Declare Function cvd# Lib "Muscle.vbx" (ByVal Lin$)
  11. 'Declare Function cvi% Lib "Muscle.vbx" (ByVal Lin$)
  12. 'Declare Function cvl& Lib "Muscle.vbx" (ByVal Lin$)
  13. 'Declare Function cvs! Lib "Muscle.vbx" (ByVal Lin$)
  14. 'Declare Function mkc$ Lib "Muscle.vbx" (a@)
  15. 'Declare Function mkd$ Lib "Muscle.vbx" (a#)
  16. 'Declare Function mki$ Lib "Muscle.vbx" (ByVal a%)
  17. 'Declare Function mkl$ Lib "Muscle.vbx" (ByVal l&)
  18. 'Declare Function MKS$ Lib "Muscle.vbx" (a!)
  19.  
  20. Declare Function GetDriveType% Lib "Kernel" (ByVal nDrive As Integer)
  21. Declare Function GetKeyboardType% Lib "Keyboard" (ByVal nTypeFlag As Integer)
  22. Declare Function GetSysColor& Lib "User" (ByVal nIndex As Integer)
  23. Declare Function SetParent% Lib "User" (ByVal hWndChild%, ByVal hWndNewParent%)
  24.  
  25. '***********************************
  26.  
  27. ' include this module with your Everest external program
  28. ' it provides the communications between Everest and your program
  29.  
  30. ' your program acts as a DDE server
  31. ' Everest is the DDE destination
  32.  
  33. '***********************************
  34.  
  35. ' put type declarations here (if any)
  36.  
  37. Type type242
  38.   chr242 As String * 1
  39.   i As Integer
  40. End Type
  41. Type type242s
  42.   s As String * 3
  43. End Type
  44. Type type243
  45.   chr243 As String * 1
  46.   l As Long
  47. End Type
  48. Type type243s
  49.   s As String * 5
  50. End Type
  51. Type type244
  52.   chr244 As String * 1
  53.   s As Single
  54. End Type
  55. Type type244s
  56.   s As String * 5
  57. End Type
  58. Type type245
  59.   chr245 As String * 1
  60.   d As Double
  61. End Type
  62. Type type245s
  63.   s As String * 9
  64. End Type
  65. Type type246
  66.   chr246 As String * 1
  67.   c As Currency
  68. End Type
  69. Type type246s
  70.   s As String * 9
  71. End Type
  72.  
  73.  
  74. '*************************************
  75.  
  76. ' put constant declarations here
  77.  
  78. Const mainpath$ = "C:\"
  79. Const yes = -1
  80. Const chr124$ = "|"
  81.  
  82. '**************************************
  83.  
  84. ' allocate local typed vars here
  85.  
  86.  
  87. ' *************************************
  88.  
  89. ' declare global variables here
  90.  
  91. Global zr%
  92. Global t242 As type242, t242s As type242s
  93. Global t243 As type243, t243s As type243s
  94. Global t244 As type244, t244s As type244s
  95. Global t245 As type245, t245s As type245s
  96. Global t246 As type246, t246s As type246s
  97.  
  98. Sub dllmgr (op%, em$)
  99. ' op% = 1: process incoming em$ execute string
  100. Static makechange%
  101.  
  102. ' init vars
  103. chr0$ = Chr$(0)
  104.  
  105. ' perform operation indicated by op%
  106.  
  107. If op% = 1 Then
  108.  
  109.   ' the following block of code puts chr 0 at proper places in em$
  110.   ' (necessary because DDE cannot transmit chr 0)
  111.   
  112.   u& = Val(Left$(em$, 5))                       ' get chr0$ sub technique (in header)
  113.   If u& < 0 Then                                ' < 0 means quick sub code
  114.     'subchar% = Abs(u&)                          ' char that means chr 0
  115.     'em$ = MhReplaceChar$(em$, subchar%, 0)      ' replace sub char with chr 0
  116.     subchr$ = Chr$(Abs(u&))
  117.     pt% = 0
  118.     Do
  119.       pt% = InStr(pt% + 1, em$, subchr$): If pt% = 0 Then Exit Do
  120.       Mid$(em$, pt%) = chr0$
  121.     Loop
  122.   Else                                          ' else, sub list technique
  123.     zl$ = Mid$(em$, 6 + u&)                     ' header + em$ to start of zl$
  124.     Do                                          ' loop through zero list
  125.       make0% = Val(zl$): If make0% <= 0 Then Exit Do
  126.       Mid$(em$, make0%) = chr0$
  127.       pt% = InStr(zl$, chr124$): If pt% = 0 Then Exit Do
  128.       zl$ = Mid$(zl$, pt% + 1)
  129.     Loop
  130.   End If
  131.  
  132.   ' next, uncompress the incoming message
  133.   ' and parse it into parameters (up to 20)
  134.  
  135.   em$ = fnExtx(em$, 6&)                         ' expand incoming message
  136.   ReDim p(20)
  137.   x% = 1: empt& = 1
  138.   Do While empt& <= Len(em$)
  139.     p(x%) = fnExtx(em$, empt&)
  140.     'If IsNumeric(p(x%)) Then p(x%) = Val(p(x%))
  141.     x% = x% + 1
  142.   Loop
  143.  
  144.   ' perform DLL or special routine call
  145.   ' put result into vary
  146.   ' (add new calls as additional CASEs here;
  147.   ' anything goes, does not have to be API call;
  148.   ' any programming you wish can go here)
  149.  
  150.   Select Case LCase$(p(1))                      ' p(1) has routine name
  151.   Case "getdrivetype"
  152.     i% = p(2)
  153.     vary = GetDriveType%(i%)
  154.   Case "getkeyboardtype"
  155.     i% = p(2)
  156.     vary = GetKeyboardType%(i%)
  157.   Case "getsyscolor"
  158.     i% = p(2)
  159.     vary = GetSysColor&(i%)
  160.   Case "**shutdown**"                           ' special message to end program
  161.     shutdown% = yes
  162.   Case Else
  163.     vary = "No such DLL routine defined: " & p(1)
  164.   End Select
  165.  
  166.   ' next, prepare reply to Everest
  167.  
  168.   em$ = Space$(6) + fnCompX$(vary)              ' 6 spaces = room for header
  169.  
  170.   ' now substitute for chr$(0) due to DDE inability to transmit chr$(0)
  171.  
  172.   For subchar% = 254 To 1 Step -1               ' look for 0 substitute candidate
  173.     If InStr(em$, Chr$(subchar%)) = 0 Then Exit For  ' this one not elsewhere in string
  174.   Next
  175.   If subchar% Then                              ' sub avail
  176.     'em$ = MhReplaceChar$(em$, 0, subchar%)      ' quickest, but requires MicroHelp's Muscle
  177.     subchr$ = Chr$(subchar%)
  178.     pt% = 0
  179.     Do
  180.       pt% = InStr(pt% + 1, em$, chr0$): If pt% = 0 Then Exit Do
  181.       Mid$(em$, pt%) = subchr$
  182.     Loop
  183.     Mid$(em$, 1, 5) = CStr(-subchar%) + "     " ' put sub char at start of em$
  184.   Else                                          ' no sub, must create list (slow!)
  185.     Mid$(em$, 1, 5) = CStr(Len(em$) - 6) + "     " ' save original em$ len
  186.     pt% = 0
  187.     Do                                          ' loop & build zero list
  188.       pt% = InStr(pt% + 1, em$, chr0$)
  189.       zl$ = zl$ + CStr(pt%) + chr124$
  190.       Mid$(em$, pt%) = "*"                      ' anything but chr$(0)
  191.     Loop
  192.     em$ = em$ + zl$                             ' put zero list on end
  193.   End If
  194.   
  195.   If makechange% >= 255 Then makechange% = 0    ' assures change event will fire in Everest
  196.   makechange% = makechange% + 1
  197.   Mid$(em$, 6) = Chr$(makechange%)
  198.  
  199.   ' send reply via Textbox (Everest is waiting for this)
  200.  
  201.   dlldde.Data.Text = em$
  202.  
  203.   ' the following applies during an Everest shutdown
  204.   ' (end this program too)
  205.  
  206.   If shutdown% Then
  207.     DoEvents
  208.     End
  209.   End If
  210. End If
  211.  
  212. End Sub
  213.  
  214. Function fnCompX$ (prop As Variant)
  215. ' "compress" incoming prop into a string
  216. ' this is the opposite of fnExtx
  217.  
  218. typ% = VarType(prop)
  219.  
  220. If typ% < 2 Then            ' 240=empty, 241=Null
  221.   fnCompX$ = Chr$(240 + typ%)
  222. ElseIf typ% = 8 Then        ' string
  223.   chars& = Len(prop)
  224.   Select Case chars&
  225.   Case 0&                   ' null string
  226.     fnCompX$ = Chr$(250)
  227.   Case Is < 240&            ' short string
  228.     fnCompX$ = Chr$(chars&) + prop
  229.   Case Is < 32000           ' medium string, use hex
  230.     fnCompX$ = Chr$(248) + Right$("0000" + Hex$(chars&), 4) & prop
  231.   Case Else
  232.     fnCompX$ = Chr$(248) + Right$("0000" + Hex$(32000), 4) & Left$(prop, 32000)
  233.     zr% = -277
  234.   End Select
  235. ElseIf typ% < 7 And prop = 0 Then   ' numeric 0
  236.   fnCompX$ = Chr$(251)
  237. ElseIf typ% = 2 Then            ' int (short)
  238.   t242.i = prop: LSet t242s = t242
  239.   fnCompX$ = t242s.s
  240. ElseIf typ% = 3 Then        ' int (long)
  241.   t243.l = prop: LSet t243s = t243
  242.   fnCompX$ = t243s.s
  243. ElseIf typ% = 4 Then        ' single
  244.   t244.s = prop: LSet t244s = t244
  245.   fnCompX$ = t244s.s
  246. ElseIf typ% = 5 Then        ' double
  247.   t245.d = prop: LSet t245s = t245
  248.   fnCompX$ = t245s.s
  249. ElseIf typ% = 6 Then        ' currency
  250.   t246.c = prop: LSet t246s = t246
  251.   fnCompX$ = t246s.s
  252. Else                        ' date (8 bytes) or newtype
  253.   fnCompX$ = Chr$(240 + typ%) & prop
  254. End If
  255.  
  256. End Function
  257.  
  258. Function fnExtx (s$, pt&)
  259. ' "extend" s$ (uncompress) and return as variant
  260. ' this is the opposite of fnCompx
  261.  
  262. On Error GoTo fnExtxerr
  263. typ% = Asc(Mid$(s$, pt&, 1)) ': pt& = pt& + 1
  264.  
  265. If typ% < 240 Then                  ' short string
  266.   pt& = pt& + 1
  267.   fnExtx = Mid(s$, pt&, typ%)
  268.   pt& = pt& + typ%
  269. ElseIf typ% = 240 Then              ' empty
  270.   pt& = pt& + 1
  271.   fnExtx = Empty
  272. ElseIf typ% = 250 Then              ' null
  273.   pt& = pt& + 1
  274.   fnExtx = ""
  275. ElseIf typ% = 251 Then              ' 0
  276.   pt& = pt& + 1
  277.   fnExtx = 0
  278. ElseIf typ% = 242 Then              ' int
  279.   t242s.s = Mid$(s$, pt&, 3): LSet t242 = t242s
  280.   fnExtx = t242.i
  281.   pt& = pt& + 3
  282. ElseIf typ% = 243 Then              ' long
  283.   t243s.s = Mid$(s$, pt&, 5): LSet t243 = t243s
  284.   fnExtx = t243.l
  285.   pt& = pt& + 5
  286. ElseIf typ% = 244 Then              ' single
  287.   t244s.s = Mid$(s$, pt&, 5): LSet t244 = t244s
  288.   fnExtx = t244.s
  289.   pt& = pt& + 5
  290. ElseIf typ% = 245 Then              ' double
  291.   t245s.s = Mid$(s$, pt&, 9): LSet t245 = t245s
  292.   fnExtx = t245.d
  293.   pt& = pt& + 9
  294. ElseIf typ% = 248 Then              ' long string
  295.   pt& = pt& + 1
  296.   fnExtx = Mid(s$, pt& + 4, Val("&H" + Mid$(s$, pt&, 4)))
  297.   pt& = pt& + typ% + 4
  298. ElseIf typ% = 249 Then              ' very long string
  299.   pt& = pt& + 1
  300.   chars& = CLng(Mid$(s$, pt&, 5))
  301.   fnExtx = Mid(s$, pt& + 5, chars&)
  302.   pt& = pt& + chars& + 5
  303. ElseIf typ% = 246 Then              ' currency
  304.   t246s.s = Mid$(s$, pt&, 9): LSet t246 = t246s
  305.   fnExtx = t246.c
  306.   pt& = pt& + 9
  307. ElseIf typ% = 247 Then              ' date
  308.   pt& = pt& + 1
  309.   fnExtx = Mid(s$, pt&, 8)
  310.   pt& = pt& + 8
  311. End If
  312. fnExtxbot:
  313. Exit Function
  314.  
  315. fnExtxerr:
  316.   fnExtx = ""
  317.   Resume fnExtxbot
  318.  
  319. End Function
  320.  
  321.